home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 7
/
Apprentice-Release7.iso
/
Environments
/
PowerLisp 2.01
/
PowerLisp 2.01 ƒ
/
Library
/
assembler_ppc.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1996-05-17
|
23KB
|
818 lines
;;;
;;; PowerLisp 2.0
;;; Copyright © 1996 Roger Corman. All rights reserved.
;;; PowerPC Assembler source
;;;
;
; Source code for assembler.
;
(eval-when (:compile-toplevel :load-toplevel :execute)
(provide :assembler)
(in-package :assembler))
(eval-when (:compile-toplevel :load-toplevel :execute)
(export
'(
r0 r1 r2 r3 r4 r5 r6 r7
r8 r9 r10 r11 r12 r13 r14 r15
r16 r17 r18 r19 r20 r21 r22 r23
r24 r25 r26 r27 r28 r29 r30 r31 sp rtoc
fp0 fp1 fp2 fp3 fp4 fp5 fp6 fp7
fp8 fp9 fp10 fp11 fp12 fp13 fp14 fp15
fp16 fp17 fp18 fp19 fp20 fp21 fp22 fp23
fp24 fp25 fp26 fp27 fp28 fp29 fp30 fp31
registers
float-registers
$CAR
$CDR
$SETCAR
$SETCDR
$SYMBOL-VALUE
$SYMBOL-PLIST
$CONSP
$INTEGER
$RETURN
$FUNC-BEGIN
$IF
$IFELSE
$LOAD-OBJ
$LOAD-LONG
$CALL
$REFERENCE
dc.l
blr
b
bl
bla
bc
bne
beq
blt
mr
stw
stwu
lwz
lbz
lbzu
addi
addis
add
or_
ori
oris
li
lis
cmpwi
cmpw
mtlr
mflr
stmw
lmw
lwzu
sraw
sraw.
andi.
lfd
mtctr
bctr
bctrl
)))
(defconstant r0 0)
(defconstant r1 1)
(defconstant r2 2)
(defconstant r3 3)
(defconstant r4 4)
(defconstant r5 5)
(defconstant r6 6)
(defconstant r7 7)
(defconstant r8 8)
(defconstant r9 9)
(defconstant r10 10)
(defconstant r11 11)
(defconstant r12 12)
(defconstant r13 13)
(defconstant r14 14)
(defconstant r15 15)
(defconstant r16 16)
(defconstant r17 17)
(defconstant r18 18)
(defconstant r19 19)
(defconstant r20 20)
(defconstant r21 21)
(defconstant r22 22)
(defconstant r23 23)
(defconstant r24 24)
(defconstant r25 25)
(defconstant r26 26)
(defconstant r27 27)
(defconstant r28 28)
(defconstant r29 29)
(defconstant r30 30)
(defconstant r31 31)
(defconstant fp0 0)
(defconstant fp1 1)
(defconstant fp2 2)
(defconstant fp3 3)
(defconstant fp4 4)
(defconstant fp5 5)
(defconstant fp6 6)
(defconstant fp7 7)
(defconstant fp8 8)
(defconstant fp9 9)
(defconstant fp10 10)
(defconstant fp11 11)
(defconstant fp12 12)
(defconstant fp13 13)
(defconstant fp14 14)
(defconstant fp15 15)
(defconstant fp16 16)
(defconstant fp17 17)
(defconstant fp18 18)
(defconstant fp19 19)
(defconstant fp20 20)
(defconstant fp21 21)
(defconstant fp22 22)
(defconstant fp23 23)
(defconstant fp24 24)
(defconstant fp25 25)
(defconstant fp26 26)
(defconstant fp27 27)
(defconstant fp28 28)
(defconstant fp29 29)
(defconstant fp30 30)
(defconstant fp31 31)
(defconstant registers
'(r0 r1 r2 r3 r4 r5 r6 r7
r8 r9 r10 r11 r12 r13 r14 r15
r16 r17 r18 r19 r20 r21 r22 r23
r24 r25 r26 r27 r28 r29 r30 r31 sp rtoc))
(defconstant sp r1)
(defconstant rtoc r2)
(defconstant float-registers
'(fp0 fp1 fp2 fp3 fp4 fp5 fp6 fp7
fp8 fp9 fp10 fp11 fp12 fp13 fp14 fp15
fp16 fp17 fp18 fp19 fp20 fp21 fp22 fp23
fp24 fp25 fp26 fp27 fp28 fp29 fp30 fp31))
;; Macros to access SYMBOL and NODE fields.
;; These are dependent on the symbol class definition.
;; The C++ source is in LispObjects.h.
(defconstant *symbol-value-offset* 8)
(defconstant *symbol-plist-offset* 12)
(defconstant *symbol-package-offset* 16)
(defconstant *symbol-name-offset* 20)
(defconstant *symbol-flags-offset* 24)
(defconstant *symbol-jump-table-entry-offset* 26)
(defconstant *symbol-jump-address-offset* 28)
(defconstant *symbol-function-offset* 32)
(defconstant *node-car-offset* 0)
(defconstant *node-cdr-offset* 4)
(defconstant *node-flags-offset* 8)
(defconstant *node-type-offset* 9)
(defvar *assembler-address* 0)
(defvar *assembler-references* nil)
;
; We do an eval-when on the entire file so that we get the
; performance benefits immediately
;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro $CAR (node &optional dest-reg)
(unless dest-reg (setq dest-reg node))
`(
(lwz ,dest-reg (,node ,*node-car-offset*))
))
(defmacro $CDR (node &optional dest-reg)
(unless dest-reg (setq dest-reg node))
`(
(lwz ,dest-reg (,node ,*node-cdr-offset*))
))
(defmacro $SETCAR (node value)
`(
(stw ,value (,node ,*node-car-offset*))
))
(defmacro $SETCDR (node value)
`(
(stw ,value (,node ,*node-cdr-offset*))
))
(defmacro $SYMBOL-VALUE (node)
`(
(lwz ,node (,node)) ;; get symbol object
(lwz ,node (,node ,*symbol-value-offset*)) ;; get value cons
(lwz ,node (,node)) ;; value in car field
))
(defmacro $SYMBOL-PLIST (node)
`(
(lwz ,node (,node)) ;; get symbol object
(lwz ,node (,node ,*symbol-plist-offset*))
))
(defmacro $CONSP (node)
`(
($IF
((andi. r0 ,node 1)) ; (if (not (integerp node)) ...
((lbz ,node (,node ,*node-type-offset*))
(cmpwi r0 0)))
))
(defmacro $INTEGER (node &optional dest-reg)
(unless dest-reg (setq dest-reg node))
`(
(sraw ,node ,node 1) ;; shift right one bit to find integer
))
;;
;; The $RETURN macro zeros out the multiple value cell, stores
;; the passed value in r3 (to return it), and unlinks the stack frame.
;;
(defmacro $RETURN (retval stacksize)
(if (eq retval 'r3)
`(
($LOAD-LONG r5 cl::%multiple-values-address)
(li r4 0)
(stw r4 (r5))
(addi sp sp ,stacksize)
(lwz r0 (sp 8))
(mtlr r0)
(blr)
)
`(
(mr r3 ,retval)
($LOAD-LONG r5 cl::%multiple-values-address)
(li r4 0)
(stw r4 (r5))
(addi sp sp ,stacksize)
(lwz r0 (sp 8))
(mtlr r0)
(blr)
)))
;;
;; The $FUNC-BEGIN macro sets up the A6 stack frame link,
;; and stores a pointer to the parameter block in A0.
;; Usage:
;; ($FUNC-BEGIN 4) ;; allocates 4 bytes (space for one object)
;; ;; on the stack
;;
(defmacro $FUNC-BEGIN (size)
`(
(mflr r0)
(stw r0 (sp 8))
; (lwz rtoc (sp 20)) ;; don't need this anymore
(stwu sp (sp ,(- size)))
))
;;
;; $IF macro
;; Usage:
;; ($IF
;; (cmpwi r7 0) ;; if r7 == 0 the next statement will be executed
;; (
;; (mr r0 r3)
;; ))
;;
(defmacro $IF (condition instructions)
(let ((temp-label (gensym)))
;; allow single instruction clauses or lists of instructions
(if (not (listp (car condition)))
(setq condition (list condition)))
(if (not (listp (car instructions)))
(setq instructions (list instructions)))
`(
,@condition
(bne ,temp-label)
,@instructions
,temp-label
)))
;;
;; $IFELSE macro
;; Usage:
;; ($IFELSE
;; (cmpwi r7 0) ;; if r7 == 0 the next instruction will be executed
;; (
;; (mr r0 r3)
;; )
;; (
;; (mr r2 r3) ;; otherwise this instruction will be executed
;; ))
;;
(defmacro $IFELSE (condition if-instructions else-instructions)
(let ((else-label (gensym))
(exit-label (gensym)))
;; allow single instruction clauses or lists of instructions
(if (not (listp (car condition)))
(setq condition (list condition)))
(if (not (listp (car if-instructions)))
(setq if-instructions (list if-instructions)))
(if (not (listp (car else-instructions)))
(setq else-instructions (list else-instructions)))
`(
,@condition
(bne ,else-label)
,@if-instructions
(b ,exit-label)
,else-label
,@else-instructions
,exit-label
)))
(defmacro $LOAD-OBJ (reg obj)
(let ((exec (eval obj)))
(add-reference obj)
`((lis ,reg ,(ash (address exec) -16))
(ori ,reg ,reg ,(mod (address exec) #x10000)))))
(defmacro $LOAD-LONG (reg n)
(if (symbolp n)
(progn
(add-reference `(symbol-value ,n))
(setq n (symbol-value n))))
`((lis ,reg ,(ash n -16))
(ori ,reg ,reg ,(mod n #x10000))))
(defmacro $CALL (func)
;; `((bla ,func))
(if (or (not (consp func))
(not (consp (cdr func)))
(not (eq (car func) 'function)))
(error "Invalid call form: ~A" func))
(add-reference func)
(let ((xaddr (exec-address (cadr func))))
`((lis r26 ,(cl::%fixnum-upper16 xaddr))
(ori r26 r26 ,(cl::%fixnum-lower16 xaddr))
(mtctr r26)
(bctrl))))
;;
;; The $REFERENCE macro does not generate any instructions, but
;; is used by the compiler as a flag to the assembler to correctly
;; generate address reference entries when code is compiled to a file.
;;
(defmacro $REFERENCE (referenced-item)
nil)
(defun check-source-reg-or-0 (source)
(if (not (or (member source registers) (zerop source)))
(error "Invalid source. source: ~A" source))
(if (not (and (integerp source) (zerop source))) (symbol-value source) source))
(defun check-source-reg (source)
(if (not (member source registers))
(error "Invalid source. source: ~A" source))
(symbol-value source))
(defun check-reg (r)
(if (not (member r registers))
(error "Invalid register. register: ~A" r))
(symbol-value r))
(defun check-float-reg (r)
(if (not (member r float-registers))
(error "Invalid floating point register. register: ~A" r))
(symbol-value r))
(defun check-dest-reg-or-0 (dest)
(if (not (or (member dest registers) (zerop dest)))
(error "Invalid destination. destination: ~A" dest))
(if (symbolp dest) (symbol-value dest) dest))
(defun check-dest-reg (dest)
(if (not (member dest registers))
(error "Invalid destination. destination: ~A" dest))
(symbol-value dest))
(defun format-sreg-dreg-u16 (instruction code sreg dreg uimm)
(setq sreg (check-source-reg sreg))
(setq dreg (check-dest-reg dreg))
(if (> (integer-length uimm) 16)
(error "Displacement too large.~%Instruction: ~A Displacement: ~A"
instruction uimm))
(+ (ash code 26) (ash sreg 21) (ash dreg 16) (logand uimm #xffff)))
(defun format-sreg-dreg-sreg (instruction code s1 d s2 scode)
(setq s1 (check-source-reg s1))
(setq d (check-dest-reg d))
(setq s2 (check-source-reg s2))
(+ (ash code 26) (ash s1 21) (ash d 16) (ash s2 11) scode))
(defun format-sreg-dreg-imm (instruction code s d imm scode)
(setq s (check-source-reg s))
(setq d (check-dest-reg d))
(+ (ash code 26) (ash s 21) (ash d 16) (ash imm 11) scode))
(defun format-fdreg-sreg-disp (instruction code fdreg sreg disp)
(setq fdreg (check-float-reg fdreg))
(setq sreg (check-source-reg sreg))
(if (> (integer-length disp) 16)
(error "Displacement too large.~%Instruction: ~A Displacement: ~A"
instruction disp))
(+ (ash code 26) (ash fdreg 21) (ash sreg 16) (logand disp #xffff)))
(defmacro dc.l (w)
(cond
((symbolp w)
(add-reference `(symbol-value ,w))
(list (symbol-value w)))
(t (list w))))
(defmacro blr () (list #x4E800020))
(defmacro bctr () (list #x4E800420))
(defmacro bctrl () (list #x4E800421))
(defmacro b (dst)
(if (symbolp dst)
(return (list (ash 18 26) dst)))
(if (consp dst)
(if (eq (car dst) 'function)
(let ((instruction 0)
(addr (exec-address (cadr dst))))
(add-reference dst)
(setq instruction (+ (ash 18 26) addr))
(return (list instruction)))
;; else
(error "Invalid destination.~%Instruction: bla Destination: ~A" dst)))
(let ((instruction 0))
(add-reference dst)
(setq instruction (+ (ash 18 26) dst))
(list instruction)))
(defmacro bl (dst)
(if (symbolp dst)
(return (list (+ (ash 18 26) 1) dst)))
(if (consp dst)
(if (eq (car dst) 'function)
(let ((instruction 0)
(addr (exec-address (cadr dst))))
(add-reference dst)
(setq instruction (+ (ash 18 26) addr 1))
(return (list instruction)))
;; else
(error "Invalid destination.~%Instruction: bla Destination: ~A" dst)))
(let ((instruction 0))
; (add-reference dst)
(setq instruction (+ (ash 18 26) dst 1))
(list instruction)))
(defmacro bc (bo bi dst)
(if (symbolp dst)
(return
(list (+ (ash 16 26) (ash bo 21) (ash bi 16)) dst)))
(if (consp dst)
(if (eq (car dst) 'function)
(let ((instruction 0)
(addr (exec-address (cadr dst))))
(add-reference dst)
(setq instruction
(+ (ash 16 26) (ash bo 21) (ash bi 16) addr))
(return (list instruction)))
;; else
(error "Invalid destination.~%Instruction: bla Destination: ~A" dst)))
(let ((instruction 0))
(add-reference dst)
(setq instruction
(+ (ash 16 26) (ash bo 21) (ash bi 16) dst))
(list instruction)))
(defmacro bne (dst) `((bc 4 2 ,dst)))
(defmacro blt (dst) `((bc 12 0 ,dst)))
(defmacro beq (dst) `((bc 12 2 ,dst)))
(defmacro bla (dst)
(if (symbolp dst)
(progn
(add-reference `(symbol-value ,dst))
(setq dst (symbol-value dst))))
(if (consp dst)
(if (eq (car dst) 'function)
(let ((instruction 0)
(addr (exec-address (cadr dst))))
(add-reference dst)
(setq addr (logior addr 3)) ; set lower 2 bits
(setq instruction (+ (ash 18 26) addr))
(return (list instruction)))
;; else
(error "Invalid destination.~%Instruction: bla Destination: ~A" dst)))
(let ((instruction 0))
(add-reference dst)
(setq instruction (+ (ash 18 26) dst))
(setq instruction (logior instruction 3)) ; set lower 2 bits
(list instruction)))
(defmacro mr (dst src) `((or_ ,dst ,src ,src)))
(defmacro stw (src dst)
(if (not (consp dst))
(error "Invalid destination.~%Instruction: stw Destination: ~A" dst))
(let ((displacement (if (cdr dst) (cadr dst) 0))
(dest-value (check-dest-reg-or-0 (car dst))))
(if (> (integer-length displacement) 15)
(error "Displacement too large.~%Instruction: stw Displacement: ~A" displacement))
(list (+ (ash 36 26)
(ash (symbol-value src) 21)
(ash dest-value 16)
(logand displacement #xffff)))))
(defmacro stmw (src dst)
(if (not (consp dst))
(error "Invalid destination.~%Instruction: stmw Destination: ~A" dst))
(let ((displacement (if (cdr dst) (cadr dst) 0))
(dest-value (check-dest-reg-or-0 (car dst))))
(if (> (integer-length displacement) 15)
(error "Displacement too large.~%Instruction: stmw Displacement: ~A" displacement))
(list (+ (ash 47 26)
(ash (symbol-value src) 21)
(ash dest-value 16)
(logand displacement #xffff)))))
(defmacro stwu (src dst)
(if (not (consp dst))
(error "Invalid destination.~%Instruction: stwu Destination: ~A" dst))
(let ((displacement (if (cdr dst) (cadr dst) 0)))
(if (> (integer-length displacement) 15)
(error "Displacement too large.~%Instruction: stwu Displacement: ~A" displacement))
(list (+ (ash 37 26)
(ash (symbol-value src) 21)
(ash (symbol-value (car dst)) 16)
(logand displacement #xffff)))))
(defmacro lwz (dst src)
(if (not (consp src))
(error "Invalid source.~%Instruction: lwz Source: ~A" src))
(let ((displacement (if (cdr src) (cadr src) 0))
(source (car src)))
(if (> (integer-length displacement) 15)
(error "Displacement too large.~%Instruction: lwz Displacement: ~A" displacement))
(setq source (check-source-reg-or-0 source))
(list (+ (ash 32 26)
(ash (symbol-value dst) 21)
(ash source 16)
(logand displacement #xffff)))))
(defmacro lmw (dst src)
(if (not (consp src))
(error "Invalid source.~%Instruction: lmw Source: ~A" src))
(let ((displacement (if (cdr src) (cadr src) 0))
(source (car src)))
(if (> (integer-length displacement) 15)
(error "Displacement too large.~%Instruction: lmw Displacement: ~A" displacement))
(setq source (check-source-reg-or-0 source))
(list (+ (ash 46 26)
(ash (symbol-value dst) 21)
(ash source 16)
(logand displacement #xffff)))))
(defmacro lwzu (dst src)
(if (not (consp src))
(error "Invalid source.~%Instruction: lwzu Source: ~A" src))
(let ((displacement (if (cdr src) (cadr src) 0))
(source (car src)))
(if (> (integer-length displacement) 15)
(error "Displacement too large.~%Instruction: lwzu Displacement: ~A" displacement))
(setq source (check-source-reg-or-0 source))
(if (zerop source)
(error "Source cannot be zero for this instruction~%Instruction: lwzu Source: ~A" src))
(list (+ (ash 33 26)
(ash (symbol-value dst) 21)
(ash source 16)
(logand displacement #xffff)))))
(defmacro lbz (dst src)
(if (not (consp src))
(error "Invalid source.~%Instruction: lbz Destination: ~A" src))
(let ((displacement (if (cdr src) (cadr src) 0))
(source (car src)))
(if (> (integer-length displacement) 15)
(error "Displacement too large.~%Instruction: lwz Displacement: ~A" displacement))
(setq source (check-source-reg-or-0 source))
(list (+ (ash 34 26)
(ash (symbol-value dst) 21)
(ash source 16)
(logand displacement #xffff)))))
(defmacro lbzu (dst src)
(if (not (consp src))
(error "Invalid source.~%Instruction: lbzu Destination: ~A" src))
(let ((displacement (if (cdr src) (cadr src) 0))
(source (car src)))
(if (> (integer-length displacement) 15)
(error "Displacement too large.~%Instruction: lwz Displacement: ~A" displacement))
(setq source (check-source-reg-or-0 source))
(list (+ (ash 35 26)
(ash (symbol-value dst) 21)
(ash source 16)
(logand displacement #xffff)))))
(defmacro addi (dst src disp)
(if (> (integer-length disp) 16)
(error "Displacement too large.~%Instruction: addi Displacement: ~A" disp))
(setq src (check-source-reg-or-0 src))
(list (+ (ash 14 26)
(ash (symbol-value dst) 21)
(ash src 16)
(logand disp #xffff))))
(defmacro add (dst src1 src2)
(list (+ (ash 31 26)
(ash (symbol-value dst) 21)
(ash (symbol-value src1) 16)
(ash (symbol-value src2) 11)
(ash 266 1))))
(defmacro addis (dst src disp)
(if (> (integer-length disp) 16)
(error "Displacement too large.~%Instruction: addis Displacement: ~A" disp))
(setq src (check-source-reg-or-0 src))
(list (+ (ash 15 26)
(ash (symbol-value dst) 21)
(ash src 16)
(logand disp #xffff))))
(defmacro or_ (dst src1 src2) (list (format-sreg-dreg-sreg 'or_ 31 src1 dst src2 888)))
(defmacro or. (dst src1 src2) (list (format-sreg-dreg-sreg 'or. 31 src1 dst src2 889)))
(defmacro ori (dst src uimm) (list (format-sreg-dreg-u16 'ori 24 src dst uimm)))
(defmacro oris (dst src uimm) (list (format-sreg-dreg-u16 'oris 25 src dst uimm)))
(defmacro li (dst disp) `((addi ,dst 0 ,disp)))
(defmacro lis (dst disp) `((addis ,dst 0 ,disp)))
(defmacro sraw (dst src shift) (list (format-sreg-dreg-imm 'sraw 31 src dst shift 1584)))
(defmacro sraw. (dst src shift) (list (format-sreg-dreg-imm 'sraw. 31 src dst shift 1585)))
(defmacro andi. (dest src uimm) (list (format-sreg-dreg-u16 'andi 28 src dest uimm)))
(defmacro lfd (fdest src)
(if (not (consp src))
(error "Invalid source.~%Instruction: lfd Destination: ~A" src))
(let ((disp (if (cdr src) (cadr src) 0))
(source (car src)))
(list (format-fdreg-sreg-disp 'lfd 50 fdest source disp))))
(defmacro cmpwi (dst simm)
(if (> (integer-length simm) 15)
(error "Immediate value too large.~%Instruction: addi Immediate: ~A" simm))
(list (+ (ash 11 26) (ash (symbol-value dst) 16) (logand simm #xffff))))
(defmacro cmpw (a b)
(setq a (check-reg a))
(setq b (check-reg b))
(list (+ (ash 31 26) (ash a 16) (ash b 11))))
(defmacro mtlr (src)
(list (+ (ash 31 26) (ash (symbol-value src) 21) (ash 8 16) (ash 467 1))))
(defmacro mflr (dst)
(list (+ (ash 31 26) (ash (symbol-value dst) 21) (ash 8 16) (ash 339 1))))
(defmacro mtctr (src)
(list (+ (ash 31 26) (ash (symbol-value src) 21) (ash 9 16) (ash 467 1))))
(defun is-relative-branch-instruction (inst)
(let ((op (ash inst -26)))
(or (= op 16) (= op 18))))
(defun merge-address (inst offset)
(let ((op (ash inst -26)))
(if (= op 16) ;; 16-bit offset
(+ inst (logand offset #xfffc))
(+ inst (logand offset #x3fffffc)))))
(defun assemble (assembler-instructions references &optional environment)
(let*
((label-table (make-hash-table :test #'eql))
(newlist nil)
(codelist nil)
(*assembler-address* 0)
(*assembler-references* nil)
operator)
(do ((n assembler-instructions (cdr n))
statement)
((null n))
(setq statement (car n))
(cond
;; if it is a label, add it to the hash table
((symbolp statement)
(setf (gethash statement label-table) *assembler-address*))
((consp statement)
(if (integerp (car statement)) ;; skip address if there is one
(setq statement (cdr statement)))
;; make sure there is a macro definition
(setq operator (car statement))
(unless (symbolp operator)
(error "Invalid instruction: ~A" operator))
(unless (macro-function operator)
(error "No definition for instruction: ~A" statement))
;; expand the macro one time
(setq statement (macroexpand-1 statement))
;; check for multiple statement result (assembler macro expansion)
(if (and (consp statement) (not (integerp (car statement))))
;; just splice in the new instructions and continue
(setq n (append (list nil) statement (cdr n)))
(if (consp statement)
(progn
(incf *assembler-address* 4)
(push statement newlist)))))
;; error if not a symbol or a list
(t (error "Invalid label encountered: ~A" statement))))
;; Now go through and append all the sublists together,
;; resolving branch addresses as we go.
;; We only currently support 16-bit displacements in the branch
;; instructions.
(setq newlist (reverse newlist))
(setq *assembler-address* 0)
(dolist (statement newlist)
;; check for branch instructions
(setq operator (car statement))
(if (is-relative-branch-instruction operator)
(if (and (consp (cdr statement))
(symbolp (cadr statement)))
(let* ((sym (cadr statement))
(value (gethash sym label-table)))
(unless value
(error "Label not found: ~A" sym))
(unless (integerp value)
(error "Invalid label found.~%Label: ~A Value: ~A" sym value))
(setf statement
(list (merge-address (car statement) (- value *assembler-address*)))))))
(incf *assembler-address* 4)
(if statement (push (car statement) codelist)))
(setq newlist nil)
(dolist (n codelist)
(push (mod n #x10000) newlist)
(push (ash n -16) newlist))
;; (let ((*print-base* 16)) (format t "newlist = ~A~%" newlist))
(%build-function newlist (nreverse *assembler-references*) environment)))
(defun add-reference (ref &optional (offset 0))
(push
(cons ref (+ *assembler-address* offset))
*assembler-references*))
) ;; close enclosing eval-when form
;; add defasm to the common lisp package
(eval-when (:compile-toplevel :load-toplevel :execute)
(in-package :common-lisp)
(export 'common-lisp::defasm))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro defasm (name lambda-list &rest forms)
; (declare (unused lambda-list))
(let ((doc-form nil))
(if (and (typep (car forms) 'string)
(cdr forms))
(progn
(setq doc-form
`((setf (documentation ',name 'function) ,(car forms))))
(setq forms (cdr forms))))
`(progn
,@doc-form
(setf (symbol-function ',name) ,(car forms))
(null-environment (function ,name))
',name)))
) ;; close eval-when